home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE18 / FONTS / PRD16.DPR < prev    next >
Text File  |  1996-11-02  |  3KB  |  94 lines
  1. program Prd16;
  2.  
  3. uses
  4.   {Next uses line needed for dynamic font stuff}
  5.   {$ifdef WIN32}
  6.     windows, messages, sysutils,
  7.   {$else}
  8.     wintypes, winprocs, messages, sysutils,
  9.   {$endif}
  10.   Forms,
  11.   Fd16 in 'FD16.PAS' {Form1};
  12.  
  13. {$R *.RES}
  14. { Returns the path to the system's TEMP dir (Win16 and Win32)}
  15. function strTempPath : string;
  16. var
  17.   strTempPath : string;
  18.   {$ifdef WIN32}
  19.     nChars : integer;
  20.   {$endif}
  21. begin
  22.   {$ifdef WIN32}
  23.     SetLength(strTempPath,255);  // allocate 255 chars in the string
  24.     nChars := GetTempPath(254,PChar(strTempPath)); // get the temp location
  25.     // Check that GetTempPath worked ok
  26.     if (nChars = 0) or (nChars > 254)  then
  27.       raise Exception.Create('Can not get location of TEMP directory');
  28.   {$else}
  29.     strTempPath := GetTempDrive('x');
  30.   {$endif}
  31.   result := strTempPath;
  32. end;
  33.  
  34. procedure LoadFont(name : string);
  35. var
  36.   pstrFotFile, pstrTmp, pzttf : array [0..250] of char;
  37.   ttf : string;
  38. begin
  39.   {Create a path to this directory & the font file}
  40.   ttf := ExtractFilePath(Application.ExeName) + name + '.ttf';
  41.   {We want to create the .fot files in the temp dir}
  42.   {$ifdef WIN32}
  43.     GetTempFileName(PChar(strTempPath), PChar(name), 1, pstrFotFile);
  44.   {$else}
  45.     GetTempFileName(GetTempDrive('x'), StrPCopy(pstrTmp,name), 1, pstrFotFile);
  46.   {$endif}
  47.   StrPCopy(pzttf,ttf);
  48.   {if the fot file exists then delete it}
  49.   DeleteFile(StrPas(pstrFotFile));
  50.   {Load the font}
  51.   if not CreateScalableFontResource(0,pstrFotFile,pzttf,nil) then
  52.     raise Exception.Create('Error in CreateScaleableFontResource.'+#10+ttf);
  53.   if AddFontResource(pstrFotFile) = 0 then
  54.     raise Exception.Create('Error in AddFontResources ' + name);
  55. end;
  56.  
  57. procedure RemoveFont(name : string);
  58. var
  59.   pstrFotFile, pstrTmp : array [0..150] of char;
  60. begin
  61.   {We'll find the .fot files in the temp dir}
  62.   {$ifdef WIN32}
  63.     GetTempFileName(PChar(strTempPath), PChar(name), 1, pstrFotFile);
  64.   {$else}
  65.     GetTempFileName(GetTempDrive('x'), StrPCopy(pstrTmp,name), 1, pstrFotFile);
  66.   {$endif}
  67.   if not RemoveFontResource(pstrFotFile) then
  68.     raise Exception.Create('Error in RemoveFontResource '+name);
  69.   DeleteFile(StrPas(pstrFotFile));
  70. end;
  71.  
  72. procedure LoadFonts;
  73. begin
  74.   LoadFont('acce');    {Accent SF}
  75. {  LoadFont('xxx'); Repeat for as many fonts as required }
  76.   {Inform the system that the fonts have changed}
  77.   SendMessage($FFFF,WM_FONTCHANGE,0,0);
  78. end;
  79.  
  80. procedure DeleteFonts;
  81. begin
  82.   RemoveFont('acce');
  83. {  RemoveFont('xxx');  This list must match the one in LoadFonts }
  84.   {Inform the system that the fonts have changed}
  85.   SendMessage($FFFF,WM_FONTCHANGE,0,0);
  86. end;
  87.  
  88. begin
  89.   LoadFonts;
  90.   Application.CreateForm(TForm1, Form1);
  91.   Application.Run;
  92.   DeleteFonts;
  93. end.
  94.